perm filename NEW.FAI[XX,LCS]5 blob
sn#233034 filedate 1976-08-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 TITLE BMSTF 0300 SUBROUTINE BMSTF
C00025 ENDMK
C⊗;
TITLE BMSTF ;0300 SUBROUTINE BMSTF
ENTRY BMSTF
EXTERNAL RHORZ,AMOD,NOZERO,LINES,BMS,MAKNUM
EXTERNAL .COMM.,ALF,POSI,STF,MIN,BM,PLTR,DL
BMSTF: 0 ;00400 IMPLICIT INTEGER(A-Q,S-Z)
;00500 REAL DIS,DISX,HGT,POS,CENTR,STFF,HGT1
;00600 COMMON/STF/RSTFAC(-3/4),RSTJ2/MIN/MINI,RMINI
;00700 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/BM/RA,RC,RJY
;00800 COMMON/POSI/STFF(-3/4),JJ2,POS/PLTR/PLT,RHT,DIS
;00900 COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
;01000 1 RJA,YY,DISX,HGT,RZ,INP(53)
;01100 EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3))
;01200 1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
;01300 1,(J11,JQ(9)),(J6,JQ(4)),(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1
;01400 1 ,(R7,RJQ(5)),(R4,RJQ(2)),(R9,RJQ(7)),(R10,RJQ(8)),(RX3,R
;01500 DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/,RBM/.83/
;01600 C RDBR IS SPACER FOR DBL BAR.
; 02000 C TO COMPENSATE FOR NOTE #3 COMING AT POS=0
BS100: MOVE 13,.COMM.+4 ; 02200 R3Q=R3
MOVE 10,.COMM.+=31 ; 10 IS J10, 13 IS R3Q
MOVE 12,STF+=8 ;2400 C NEXT IS FOR BEAMS
MOVEM 12,MIN+1 ;2500 RMINI=RSTJ2
; 02600 RX=2.7*RSTJ2*5.96
FMPR 12,[16.092] ; 12 IS RX
MOVE 5,.COMM.+=10 ; SAVE R9 IN 5
MOVE 6,.COMM.+=28 ; 6 IS J7
MOVE 14,.COMM.+=29 ; J8
;; MOVE .COMM.+5 ;IF(R4.GE.80)R4=R4-100
;; CAMGE [-20.0] ;CHECK FOR -95, ETC.
;; FADR [100.0]
;; CAMGE [80.0] ;CATCHES SOME NEG. MINIS (I.E.<-100)
;; JRST .+3
;; FSBR [100.0]
;; MOVEM .COMM.+5 ;**** ALL DONE IN CENTX NOW (LOOP.FAI)****
JSA 16,RHORZ ; 02800 R6=RHORZ(R6)
JUMP .COMM.+7
MOVEM 00,.COMM.+7
;*** MOVSI 2,204500 ; (10.0) IF(R8.NE.0)GO TO 204
;*** SKIPN .COMM.+=9
;*** CAMG 2,.COMM.+=11
;*** JRST BS204 ; IF(R10.GE.10)GO TO 204
;; JUMPE 5,BSJ8 ; IF(J9.EQ.0)GO TO BSJ8 *** NEW***
JUMPGE 14,BSJ8 ; IF(J8.GE.0)GO TO BSJ8 ***NEW***
JUMPE 5,BS91+2
MOVN 10,14
;; SETZM .COMM.+=9 ;R8=0
BSJ8: JUMPL 6,BS204 ; 03100 IF(J7)GO TO 204
SKIPN 10 ;IF(J10.NOW IS NE.0)GO TO 204
JUMPN 5,BS1 ; 03200 IF(R9.NE.0)GO TO 1
; R8=0 AND R9=NUM -- PUTS NUMBER OUTSIDE BEAM(FOR TRIPLET
BS204: JUMPE 5,BSR9 ;03400 204 IF(R9.NE.0)R9=RHORZ(R9)
;; JUMPG 5,BSX9
;; MOVE 5,0 ;IF(R9.LT.0)R9=R6 ***NEW***
;; JRST BSR9
BSX9: JSA 16,RHORZ
JUMP .COMM.+=10
MOVEM 5 ; 5 IS R9
BSR9: JUMPL 6,BS201 ; IF(J7)GO TO 201
;***BS200: CAIGE 10,=10 ; 200 IF(J10.LT.10)GO TO 91
;*** JRST BS91
;; JUMPE 10,BS91 ;IF(J10.EQ.0)GO TO 91 NEXT FOR INNER, PARTIAL BEAMS
;; CAME 14,[-1]
;; JRST BSX8 ;IF(R8.EQ.-1)R8=R3 ***NEW***
;; MOVEM 13,.COMM.+=9
;; JRST BSR8
JUMPE 14,BS91 ;IF(J8.EQ.0)GO TO 91
JUMPLE 14,BSR8 ;IF(J8.LE.0)GO TO BSR8
BSX8: JSA 16,RHORZ ; 03800 R8=RHORZ(R8)
JUMP .COMM.+=9
MOVEM 00,.COMM.+=9
;*** JSA 16,AMOD ; 03900 R10=AMOD(R10,10.)
;*** JUMP .COMM.+=11
;*** JUMP [10.0]
;*** MOVEM 00,.COMM.+=11
BSR8: MOVE 02,10 ;J10/10 =0 OR 1 OR 2
IDIVI 02,12
FLTR 3,3
MOVEM 3,.COMM.+=11 ;R10 NOW = DISPLACEMENT
;*** CAIN 2,3
;*** JRST BS4
JUMPN 2,.+3
ADDI 10,12 ;J10=J10+10 CHANGES 1 TO 11, ETC.
JRST BS4
CAIN 2,2
JRST BS3 ;4100 2 RH=R9+RX
BS2: MOVE 02,12
FADR 02,5
MOVEM 02,RH#
JRST BS1
BS3: MOVN 02,12 ;4300 3 R8=R9-RX
FADR 02,5
MOVEM 02,.COMM.+=9;10=SHRT PARTIAL LFT↑RT., 20=RT.↑LFT, 30=TO POS IN P8
BS4: MOVE 02,.COMM.+=9 ;4500 4 RH=R8
MOVEM 02,RH ;4600 C LEFT INNER POS.
JRST BS1
BS201: MOVNS 6 ;4800 201 J7=-J7
;4900 C P8=WIDTH OF TREM. P9=0(SANS OTHER BEAMS) OR =POS.3, P10=D
FLTR 0,10 ;5000 CALL NOZERO(R10)
SKIPN
MOVE [1.0] ;ALWAYS AT LEAST 1 IN DISPLACEMENT (AC.0)
;*** JSA 16,NOZERO
;*** JUMP .COMM.+=11
MOVEI 10,36 ;05200 J10=30
; TO ACTIVATE PARTIAL BEAM SECTION
MOVE 02,.COMM.+=30 ;5400 IF(J9.NE.0)GO TO 202
JUMPN 02,BS202
; 05500 C NEXT FOR TREM. WITHOUT OTHER BEAMS.
MOVSI 02,576400 ;5600 RH=-1
CAIL 6,24 ;5700 IF(J7.GE.20)RH=-RH
MOVNS 2
MOVEM 02,RH
FADR 02,.COMM.+5 ;6000 R5=R4+RH
MOVEM 02,.COMM.+6
; 06100 R9=R3
MOVE 05,.COMM.+4
; 06200 R6=R3+22.*RMINI
MOVSI 02,205540
FMPR 02,MIN+1
FADR 02,.COMM.+4
MOVEM 02,.COMM.+7
; 06300 202 IF(R8.EQ.0)R8=4.
BS202: MOVE 12,.COMM.+=9
JUMPN 12,.+3
MOVSI 12,203400
MOVEM 12,.COMM.+=9
; 06400 RX=R8*RMINI*2.98
FMPR 12,MIN+1
FMPR 12,[2.98]
; 06500 RH=R9+RX
MOVE 02,12
FADR 02,5
MOVEM 02,RH
; 06600 R9=R9-RX
MOVN 02,12
FADRM 02,5
; 06700 GO TO 1
JRST BS1
BS91: JUMPE 14,BS1 ; 91 IF(J8.EQ.0)GO TO 1
JUMPG 14,BS92 ; IF(J8.GT.0)GO TO 92
; FOR J8=-(10+DN) OR -(20+DN) R9=R3+RX
MOVE 5,.COMM.+4
FADR 5,12 ; IF(J8.LE.-20)R9=R6-RX
CAMLE 14,[-=20]
JRST .+3
MOVN 5,12
FADR 5,.COMM.+7
; 07400 192 J8=-J8
BS192: MOVNS 14
BS92: JUMPN 10,.+3 ;92 IF(J10.EQ.0)J10=MOD(J8,10)
MOVE 7,14
IDIVI 7,=10 ; IF(J10.EQ.0)J10=1
SKIPN 10
MOVEI 10,1
FLTR 2,10 ;MOVE 2,10 ; R10=J10
; TLC 2,232000
; FADR 2,2
MOVEM 2,.COMM.+=11 ;IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
; 08000 1 IF(IABS(J4).LT.100)GO TO 97
BS1: MOVM .COMM.+=25
CAIGE 00,=80
JRST BS97
; 08100 RMINI=.6*RSTJ2
MOVE 02,[0.6]
FMPR 02,STF+=8
MOVEM 02,MIN+1
;; JSA 16,AMOD ;8200 R5=AMOD(R5,100.0)
;; JUMP .COMM.+6
;; JUMP [100.0]
;; MOVEM 00,.COMM.+6 ; SPACE BETWEEN BEAMS
BS97: MOVSI 2,204540 ;8400 97 RJ=RMINI*11.
FMPR 2,MIN+1
MOVEM 2,ALF+=11
MOVSI 206600 ;MOVE [48.0] ;RW=RMINI*RHGT
FMPR MIN+1
MOVEM ALF+=9 ; DIST. UP OR DOWN FROM NOTE HEAD.
FMPR 2,.COMM.+=11 ;RJA=R10*RJ
MOVEM 2,ALF+=14 ; DISPLACEMENT
MOVEM 5,.COMM.+=10 ; RD=R9
MOVEM 5,ALF+7 ; POSITION 3
FSBR 2,ALF+=9
FADR 02,.COMM.+2 ; RJX=CENTR-RW+RJA
MOVEM 02,ALF+=10 ; FINAL HEIGHT OF LEFT SIDE
; 09300 C NEG R7=TREMOLO
; 09400 RX=MOD(J7,10)
MOVE 11,6
IDIVI 11,=10
FLTR 12,12 ;TLC 12,232000
;FADR 12,12
MOVEI 1,(6) ; PUT J7 IN 1 FOR NOW
SUBI 6,=20 ;9500 JJ2=J7-20
; 09600 RA=R6
MOVE 02,.COMM.+7
MOVEM 02,BM ; HORIZANTAL DIST.
; RJY=R5*RST7+POS-RST18-RW+RJA
MOVSI 3,203700 ; 7.0
FMPR 03,.COMM.+6
FSBR 3,[18.0]
FMPR 3,STF+=8
FADR 3,ALF+=14
FADR 3,POSI+=9
FSBR 3,ALF+=9
MOVEM 3,BM+2 ; VERTICAL POS OF RIGHT SIDE.
; 10000 RW=R14*RMINI
MOVE 4,[14.54]
FMPR 4,MIN+1
MOVEM 4,ALF+=9
MOVSI 0,202400 ;2.0 10100 RY=1./(RHT*RMINI)
MOVSI 02,201400 ;*****************8/76
CAMG 0,DL ;IF(RSIZ.GE.2)RY=2./ ....
MOVE 2,0
FDVR 2,DL ;/RSIZ
FDVR 2,MIN+1 ;/RMINI
MOVEM 02,RY#
CAIL 1,24 ;200 IF(J7.GE.20)GO TO 98
JRST BS98 ; JUMP IF STEMS ARE DOWN
; 10400 RY=-RY
MOVNS 00,RY
; 10500 C FOR THICKENING INCR.
ADDI 6,=10 ;0600 JJ2=J7-10
; 10700 RJ=-RJ
MOVNS 00,ALF+=11
; 10800 RJA=RMINI*R2HGT-2.*RJA
MOVE 02,[96.0]
FMPR 02,MIN+1
MOVE 03,ALF+=14
FSC 03,1
FSBR 02,3
MOVEM 02,ALF+=14
; 10900 RJX=RJX+RJA
FADRM 02,ALF+=10
; 11000 RJY=RJY+RJA
FADRM 02,BM+2
; 11100 R3Q=R3Q+RW
FADRM 4,13 ; POSITION 1
; 11300 RA=RA+RW
FADRM 4,BM ; POSITION 2
; 11500 RD=RD+RW
FADRM 4,ALF+7
; 11700 RH=RH+RW
FADRM 4,RH
; 11800 98 RSTJ2=RSTJ2*RBM
BS98: MOVE 02,[0.83]
FMPRM 02,STF+=8
; RBM BRINGS LINES OF BEAMS CLOSER TOGETHER. (=.83)
MOVEM 6,POSI+=8 ; JJ2 12000 93 IF(JJ2.GT.RX)GO TO 94
FLTR 6,6 ;TLC 6,232000
; FADR 6,6
CAMLE 6,12
JRST BS94
CAIL 10,=10 ;2100 IF(J10.GE.10)GO TO 7
JRST BS7
;XXX JUMPN 10,BS7 ;IF(J10.NE.0)GO TO 7
; 12200 C**********************
JUMPE 14,BS94 ; IF(J8.EQ.0)GO TO 94
; 12400 R3=RW
; 12500 IF(J9.EQ.0)GO TO 292
MOVE 02,.COMM.+=30
JUMPE 02,BS292
CAIL 14,24 ; IF(J8.GE.20)GO TO 193
JRST BS193
; 12700 293 RX=R3Q-RD
BS293: MOVE 12,13
FSBR 12,ALF+7
; 12800 GO TO 194
JRST BS194
; 12900 7 RHX=RH-R3Q
; 13000 R3=RD-R3Q
BS7: MOVN 4,13
FADR 4,ALF+7
; 13100 GO TO 292
JRST BS292
; 13200 193 RX=RD-RA
BS193: MOVE 12,ALF+7
FSBR 12,BM ; 13300 194 R3=ABS(RX)
BS194: MOVM 4,12 ; 13400 292 DISX=ABS(R3Q-RA)
BS292: MOVE 02,13
FSBR 02,BM
MOVMM 02,ALF+=16 ;13500 HGT=RJX-RJY
MOVE 3,ALF+=10
FSBR 3,BM+2
MOVEM 3,HGT#
CAIGE 10,=10 ;3600 IF(J10.GE.10)HGT1=HGT*RHX/DISX
JRST BS10
;XXX JUMPE 10,BS10 ;IF(J10.EQ.0)GO TO 10
MOVN 1,13
FADR 1,RH
FMPR 1,3
FDVR 1,2 ; 1 HAS -HGT1
BS10: FDVR 4,ALF+=16 ;13800 R3=R3/DISX
MOVEM 4,.COMM.+4 ;13900 195 HGT=HGT*R3
FMPRB 4,HGT ; 14000 196 L=J8/10
SETZM .COMM.+=29 ; 14100 J8=0
CAIL 10,=10 ;14200 IF(J10.GE.10)GO TO 8
JRST BS8
;XXX JUMPN 10,BS8 ;IF(J10.NE.0)GO TO 8
IDIVI 14,=10 ;( L=J8/10)
CAIN 14,1 ; IF(L.EQ.1)GO TO 95
JRST BS95 ;BEAM LFT=1, RT=2 (PARAM 8=10 OR 20)
; 14600 R3Q=RD
MOVE 13,ALF+7 ; 14700 RJX=RJY+HGT
FADR 04,BM+2 ; 4 WAS HGT
MOVEM 04,ALF+=10 ; 14800 GO TO 94
JRST BS94 ; 15000 8 R3Q=RH
BS8: MOVE 13,RH ;15200 RJY=RJX-HGT
MOVE 02,ALF+=10
FSBR 02,HGT
MOVEM 02,BM+2
FADRM 1,ALF+=10 ;15300 RJX=RJX-HGT1
; 15400 GO TO 94
JRST BS94-2 ; 15500 95 RA=RD
; 15600 RJY=RJX-HGT
BS95: MOVE 02,ALF+=10
FSBR 02,HGT
MOVEM 02,BM+2
MOVE 02,ALF+7
MOVEM 02,BM
BS94: MOVEM 13,ALF+5 ;(R3Q)15700 94 L=7.*RMINI
MOVE 13,PLTR ; AC13 SHOULD NOT BE TAMPERED WITH!
JUMPGE 13,BS930 ;IF(PLT.GE.0)GO TO 930 (SKIP FOR DPY)
MOVSI 02,203740 ; WAS 7.0 (203700)
FMPR 2,MIN+1 ;7.5*RMINI*RSIZ (DL)
FMPR 2,DL ;MAKES CORRECT THICKNESS ON PLOTTER.
KIFIX 0,2 ;JSA 16,IFIX
MOVSI 2,202400 ;IF(RSIZ.GE.2.0)L=L/2 HALF AS MANY LINES.
CAMG 2,DL
IDIVI 0,2 ;********** 8/76
MOVEM 00,ALF+=12 ;15800 930 RC=0
BS930: SETZM BM+1
; C MINI LINES HAVE .2 SMALLER BEAMS. MAYBE CHANGE THIS??
JSA 16,LINES ;16000 CALL LINES(R3Q,RJX,3)
JUMP ALF+5
JUMP ALF+=10
JUMP [3] ;16100 DO 941 K=1,L
MOVEI 15,1 ; 16200 CALL BMS
BS12: JSA 16,BMS ;16300 IF(PLT.GE.0)GO TO 940
JUMPGE 13,BS940 ; 16400 RC=RC+RY
MOVE 02,RY
FADRM 02,BM+1 ; FOR THICKENING.
JSA 16,BMS ;16600 CALL BMS
MOVE 1,ALF+5 ; CALL EXCH(RA,ALF+5)
EXCH 1,BM
MOVEM 1,ALF+5
MOVE 1,ALF+=10
EXCH 1,BM+2 ; 941 CALL EXCH(RJY,RJX)
MOVEM 1,ALF+=10
CAMGE 15,ALF+=12
AOJA 15,BS12 ; 16900 CALL BMS
JSA 16,BMS ; DRAWS 5 LINES FOR BEAMS.
; 17100 940 JJ2=JJ2-1
BS940: SOSG POSI+=8 ; 17200 IF(JJ2.LE.0)GO TO 942
JRST BS942 ; IF P7=10 OR 20 ONE BEAM WILL APPEAR.
; 17400 RJY=RJY+RJ
MOVE 02,ALF+=11
FADRM 02,BM+2 ; 17500 RJX=RJX+RJ
FADRM 02,ALF+=10
JRST BS930 ;17600 GO TO 930
BS942: SKIPN 14 ;17800 942 IF(J8.NE.0)RETURN
SKIPN .COMM.+=30
JRA 16,(16) ;17900 IF(J9.EQ.0)RETURN
MOVSI 02,205740 ;18000 IF(R10.GE.30)RETURN
SKIPL .COMM.+=28 ;IF(J7.LT.0)RETURN
CAMG 02,.COMM.+=11
JRA 16,(16) ; C FOR NUMBERS OUTSIDE BEAMS
MOVE 02,MIN+1 ;18200 RSTJ2=RMINI
MOVEM 02,STF+=8
MOVN 3,[10.0] ;18300 RD=-10.
MOVSI 02,205500 ;18400 IF(R7.LT.20)RD=8.3
CAMLE 02,.COMM.+=8
MOVE 3,[8.3]
BS943: MOVN 02,ALF+5 ;18500 943 J3=R3Q+(RA-R3Q)/2.
FADR 02,BM
FSC 02,777777
FADR 02,ALF+5
KIFIX 0,2 ;FIX IT
MOVEM 00,.COMM.+=24 ;18600 R6=1.
MOVSI 02,201400
MOVEM 02,.COMM.+7 ;18900 R7=1
MOVEM 02,.COMM.+=8 ; C ITALICS
; 18800 R4=R4+(R5-R4)/2.+RD
MOVE 02,.COMM.+6
FSBR 02,.COMM.+5
FSC 02,777777
FADR 2,3
FADRM 02,.COMM.+5 ↔ SETZM .COMM.+=12 ; R11=0
; 19100 CALL MAKNUM(R9)
JSA 16,MAKNUM
JUMP .COMM.+=10
JRA 16,(16) ; 19300 END
END